;; -*- Mode:Lisp; Package:FORMAT; Base:8 -*-
;; Function for printing or creating nicely formatted strings.
;; written by Andrew L. Ressler on September 8, 1982
;; copyright LISP MACHINE INC.
;; permission granted to anyone to use this or modify it.

;; attempt to turn format into a macro facility
;; if it can't do it easily it just makes it call format instead.

(defvar format-results NIL)
(defvar final-format-results NIL)
(defvar inside-conditional NIL)
(defvar optimize-lets T)

(defmacro format-macro (stream ctl-string &REST args)
  (prog ()
        (setq final-format-results NIL)
        (let ((FORMAT-ARGLIST ARGS)
              (LOOP-ARGLIST NIL)(value))
          (setq value
                (*Catch 'IMPOSSIBLE
                  (*CATCH 'FORMAT-/:^-POINT
                    (*CATCH 'FORMAT-^-POINT
                      (COND ((STRINGP CTL-STRING)
                             (FORMAT-CTL-STRING-macro ARGS CTL-STRING))
                            (T (return `(format ,stream ,ctl-string . ,args))))))))
          (if (eq value 'IMPOSSIBLE)
              (return `(format ,stream ,ctl-string . ,args))))
        (return
          (let ((result
                  (if (null stream)
                      `(progn
                         ;;; Only bind FORMAT-STRING if STREAM is NIL.  This avoids lossage if
                         ;;; FORMAT with a first arg of NIL calls FORMAT recursively (e.g. if
                         ;;; printing a named structure).
                         (bind (value-cell-location 'FORMAT-STRING)
                               (make-array 200
                                           ':AREA FORMAT-TEMPORARY-AREA
                                           ':TYPE 'ART-STRING
                                           ':LEADER-LIST '(0)))
                         (let ((standard-output 'FORMAT-STRING-STREAM))
                           ,@(nreverse final-format-results))
                         (prog1 (substring format-string 0)
                                (return-array format-string)))
                    `(let ((standard-output
                             ,(cond ((eq stream T) 'standard-output)
                                    (T stream))))
                       . ,(nreverse final-format-results)))))
            (if optimize-lets
                (setq result (elim-lets result))
              result)))))

(defun format-ctl-string-macro (ARGS CTL-STRING &AUX (FORMAT-PARAMS NIL))
  (UNWIND-PROTECT
      (DO ((CTL-INDEX 0)
           (CTL-LENGTH (ARRAY-ACTIVE-LENGTH CTL-STRING))
           (TEM))
          ((>= CTL-INDEX CTL-LENGTH))
        (SETQ TEM (%STRING-SEARCH-CHAR #/~ CTL-STRING CTL-INDEX CTL-LENGTH))
        (COND ((NEQ TEM CTL-INDEX)                      ;Put out some literal string
               (push `(funcall standard-output
                               ':STRING-OUT
                               ,(substring CTL-STRING CTL-INDEX
                                           ;If you really supply the fourth arg,
                                           ;it had better be a string index or some
                                           ;streams will bomb.
                                           (IF (NULL TEM)
                                               (ARRAY-ACTIVE-LENGTH CTL-STRING)
                                             tem)))
                     final-format-results)
               (IF (NULL TEM) (RETURN))
               (SETQ CTL-INDEX TEM)))
        ;; (AREF CTL-STRING CTL-INDEX) is a tilde.
        (LET ((ATSIGN-FLAG NIL)
              (COLON-FLAG NIL)
              (format-results NIL)
              (flush-let NIL))
          (IF (NULL FORMAT-PARAMS)
              (SETQ FORMAT-PARAMS (ALLOCATE-RESOURCE 'FORMAT-PARAMS)))
          (STORE-ARRAY-LEADER 0 FORMAT-PARAMS 0)
          (MULTIPLE-VALUE (TEM ARGS) (FORMAT-PARSE-COMMAND ARGS T))
          (multiple-value (ARGS flush-let)
            (FORMAT-CTL-OP-macro TEM ARGS (G-L-P FORMAT-PARAMS)))
          (if flush-let
              (push (cons 'PROGN (nreverse format-results)) final-format-results)
            (push `(let ((atsign-flag ,ATSIGN-FLAG)
                         (colon-flag ,colon-flag))
                     . ,(nreverse format-results))
                  final-format-results))))
    (AND FORMAT-PARAMS (DEALLOCATE-RESOURCE 'FORMAT-PARAMS FORMAT-PARAMS)))
  ARGS)


;Perform a single formatted output operation on specified args.
;Return the remaining args not used up by the operation.
(defun format-ctl-op-macro (op args params &AUX tem immediate)
    (cond ((null op) (format-error "Undefined FORMAT command.") args) ;e.g. not interned
          ((setq tem (get op 'FORMAT-CTL-ONE-ARG))
           (if (setq immediate (get op 'EVAL-IMMEDIATE))
               (progn
                 (funcall immediate (car args) params)
                 (values (cdr args) T))
             (push `(funcall ',tem ,(copytree (first args)) ',(copytree params))
                   format-results)
             (cdr args)))
          ((setq tem (get op 'FORMAT-CTL-NO-ARG))
           (if (setq immediate (get op 'eval-immediate))
               (progn
                 (funcall immediate params)
                 (values args T))
             (push `(funcall ',TEM ',(copytree params)) format-results)
             args))
          ((setq tem (get op 'FORMAT-CTL-MULTI-ARG))
           (if (setq immediate (get op 'eval-immediate))
               (values (funcall immediate args params) T)
             (push `(funcall ',TEM ,(copytree args) ,(copytree params)) format-results)))
          ((setq tem (get op 'FORMAT-CTL-REPEAT-CHAR))
           (push `(format-ctl-repeat-char ,(copytree (or (first params) 1)) ,tem)
                 format-results)
           (values args T))
          (T (FORMAT-ERROR "/"~S/" is not defined as a FORMAT command." OP)
             args)))

(defprop * format-ctl-ignore-macro eval-immediate)
(defun format-ctl-ignore-macro (args params &AUX (count (or (car params) 1)))
  (if colon-flag
      (do ((a format-arglist (cdr a))
           (b (nthcdr count format-arglist) (cdr b)))
          ((null a) (format-error "Can't back up properly for a ~:*"))
        (and (eq b args) (return a)))
    (nthcdr count args)))

(defprop crlf crlf-macro eval-immediate)
(defun crlf-macro (ignore)
  (and atsign-flag
       (push '(funcall standard-output ':TYO #\CR) format-results)))

(defprop % format-ctl-newlines-macro eval-immediate)
(defun format-ctl-newlines-macro (params &AUX (count (or (car params) 1)))
  (dotimes (i count)
    (push '(funcall standard-output ':TYO #\CR) format-results)))


(defprop & format-ctl-fresh-line-macro eval-immediate)
(defun format-ctl-fresh-line-macro (params &AUX (count (or (car params) 1)))
  (push '(funcall standard-output ':FRESH-LINE) format-results)
  (do i (1- count) (1- i) (= i 0)
      (push '(FUNCALL STANDARD-OUTPUT ':TYO #\CR) format-results)))


(defprop d format-ctl-decimal-macro eval-immediate)
(defun format-ctl-decimal-macro (arg params &OPTIONAL (base 10.)        ;Also called for octal
                                 &AUX
                                 (width (first params))
                                 (padchar (second params))
                                 (commachar (third params))
                                 (gen-arg (gensym)))
  (setq padchar (cond ((null padchar) #\SP)
                      ((numberp padchar) padchar)
                      (T (aref (string padchar) 0)))
        commachar (cond ((null commachar) #/,)
                        ((numberp commachar) commachar)
                        (T (aref (string commachar) 0))))
  (push
    `(let ((base ,base)(*nopoint T)(,gen-arg ,arg))
       ,@(if width
             `((format-ctl-justify
                 ,width
                 (+ (if (typep ,gen-arg ':FIXNUM)
                        (+ (LOOP FOR x = (abs ,gen-arg) THEN (// x base)
                                 COUNT T
                                 UNTIL (< x base))
                           (if (minusp ,gen-arg) 1 0))
                      (flatc ,gen-arg))
                    ,(if atsign-flag
                         `(if (and (numberp ,gen-arg)(not (minusp ,gen-arg))) 1 0)
                       0)
                    ,(if colon-flag
                         `(if (fixp ,gen-arg) (// (1- (flatc (abs ,gen-arg))) 3) 0) 0))
                 ,padchar)) NIL)
       ,@(if atsign-flag
             `((if (and (numberp ,gen-arg)(not (minusp ,gen-arg)))
                   (funcall standard-output ':TYO #/+)))
           NIL)
       ,(if colon-flag
            `(cond ((fixp ,gen-arg)
                    ;; Random hair with commas.  I'm not going to bother not consing.
                    (cond ((minusp ,gen-arg)
                           (funcall standard-output ':TYO #/-) (setq ,gen-arg (- ,gen-arg))))
                    (setq ,gen-arg (nreverse (inhibit-style-warnings    ;Give up!
                                           (exploden ,gen-arg))))
                    (do ((l ,gen-arg (cdr l))
                         (i 2 (1- i)))
                        ((null (cdr l)))
                      (cond ((zerop i)
                             (rplacd l (cons ,commachar (cdr l)))
                             (setq i 3 l (cdr l)))))
                    (dolist (ch (nreverse ,gen-arg))
                      (funcall standard-output ':TYO ch)))
                   ((typep ,gen-arg ':FIXNUM) (si:print-fixnum ,gen-arg standard-output))
                   ;; This is PRINC rather than PRIN1
                   ;; so you can have a string instead of a number
                   (T (princ ,gen-arg)))
          `(cond ((typep ,gen-arg ':FIXNUM) (si:print-fixnum ,gen-arg standard-output))
                 ;; This is PRINC rather than PRIN1
                 ;; so you can have a string instead of a number
                 (T (princ ,gen-arg)))))
    format-results))

(defprop o format-ctl-octal-macro eval-immediate)
(defun format-ctl-octal-macro (arg params)
  (format-ctl-decimal-macro arg params 8))

(defprop f format-ctl-f-format-macro eval-immediate)
(defun format-ctl-f-format-macro (arg params)
  (push
    `(let ((arg ,arg))
       (and (numberp arg) (not (floatp arg)) (setq arg (float arg)))
       (if (not (floatp arg))
           ,(let ((format-results NIL))
              (format-ctl-decimal-macro 'ARG NIL)
              format-results)
         (si:print-flonum arg standard-output NIL (small-floatp arg)
                          ,(first params) NIL)))
    format-results))

(defprop e format-ctl-e-format-macro eval-immediate)
(defun format-ctl-e-format-macro (arg params)
  (push
    `(let ((arg ,arg))
       (and (numberp arg) (not (floatp arg)) (setq arg (float arg)))
       (if (not (floatp arg))
           ,(let ((format-results NIL))
              (format-ctl-decimal-macro 'ARG NIL)
              format-results)
         (si:print-flonum arg standard-output NIL (small-floatp arg)
                          ,(first params) T)))
    format-results))


(defprop A format-ctl-ascii-macro eval-immediate)
(defun format-ctl-ascii-macro (arg params &OPTIONAL prin1p)
  (let ((edge (car params))
        (period (cadr params))
        (min (caddr params))
        (padchar (cadddr params)))
    (cond ((null padchar)
           (setq padchar #\SP))
          ((not (numberp padchar))
           (setq padchar (character padchar))))
    (cond (atsign-flag)                         ;~@5nA right justifies
          (colon-flag
           (if prin1p
               (push `(cond ((null ,arg)
                             (funcall standard-output ':STRING-OUT "()"))
                            (T (prin1 ,ARG))) format-results)
             (push `(cond ((null ,arg)
                           (funcall standard-output ':STRING-OUT "()"))
                          ((stringp ,arg) (funcall standard-output ':STRING-OUT ,arg))
                          (T (princ ,arg))) format-results)))
          (prin1p (push `(prin1 ,ARG) format-results))
          (T (push `(if (stringp ,ARG)(funcall standard-output ':STRING-OUT ,ARG)
                      (princ ,ARG)) format-results)))
    (cond ((not (null edge))
           (push
             `(let ((width ,(if prin1p
                                `(funcall #'FLATSIZE ,ARG)
                              `(cond ((stringp ,ARG) #'ARRAY-ACTIVE-LENGTH)
                                     (T #'FLATC)))))
                ,@(cond (min
                         `((progn
                             (format-ctl-repeat-char ,min ,padchar)
                             (setq width (+ width ,min))))))
                ,(cond (period
                         `(progn
                            (format-ctl-repeat-char
                              (- (+ ,edge (* (// (+ (- (max ,edge width) ,edge 1)
                                                    ,period)
                                                 ,period)
                                             ,period))
                                 width)
                              ,padchar)))
                        (T (progn `(format-ctl-justify edge width ,padchar)))))
             format-results)))
    (cond ((null atsign-flag))
          (colon-flag
           (if prin1p
               (push `(cond ((null ,arg)
                             (funcall standard-output ':STRING-OUT "()"))
                            (T (prin1 ,ARG))) format-results)
             (push `(cond ((null ,arg)
                           (funcall standard-output ':STRING-OUT "()"))
                          ((stringp ,arg) (funcall standard-output ':STRING-OUT ,arg))
                          (T (princ ,arg))) format-results)))
          (prin1p (push `(prin1 ,ARG) format-results))
          (T (push `(if (stringp ,ARG)(funcall standard-output ':STRING-OUT ,ARG)
                      (princ ,ARG)) format-results)))))

(defprop s format-ctl-sexp-macro eval-immediate)
(defun format-ctl-sexp-macro (arg params)
    (format-ctl-ascii-macro arg params T))

(defprop g format-ctl-goto-macro eval-immediate)
(defun format-ctl-goto-macro (ignore params &AUX (count (or (car params) 1)))
  (nthcdr count format-arglist))

(defprop p format-ctl-plural-macro eval-immediate)
(defun format-ctl-plural-macro (args ignore)
  (and colon-flag (setq args (format-ctl-ignore-macro args NIL))) ;crock: COLON-FLAG is set
  (if atsign-flag
      (push `(if (equal ,(car args) 1)
                 (funcall standard-output ':TYO #/y)
               (funcall standard-output ':STRING-OUT "ies"))
            format-results)
    (push `(or (equal,(car args) 1) (funcall standard-output ':TYO #/s)) format-results))
  (cdr args))

(defprop q format-ctl-apply-macro eval-immediate)
(defun format-ctl-apply-macro (arg params)
  (push `(apply ,arg ,params) format-results))

(defprop t format-ctl-tab-macro eval-immediate)
(defun format-ctl-tab-macro (params &AUX (dest (or (first params) 1))
                             (extra (or (second params) 1)))
  (push
    `(let ((ops (funcall standard-output ':WHICH-OPERATIONS))(incr-ok))
       (cond ((or (setq incr-ok (memq ':INCREMENT-CURSORPOS ops))
                  (memq ':SET-CURSORPOS ops))
              (multiple-value-bind (x y) (funcall standard-output ':READ-CURSORPOS
                                                  ,(if colon-flag '':PIXEL '':CHARACTER))
                (let ((new-x              ;next multiple of EXTRA after X
                        (if (< x ,dest) ,dest
                          ,(if (eq extra 1)
                               `(1+ x)
                             `(* (1+ (// x ,extra)) ,extra)))))
                  (cond (incr-ok
                         ;; Use :INCREMENT-CURSORPOS preferentially
                         ;; because it will do a **MORE** if we need one.
                         (funcall standard-output ':INCREMENT-CURSORPOS
                                  (- new-x x) 0  ,(if colon-flag '':PIXEL '':CHARACTER)))
                        (T
                         (funcall standard-output ':SET-CURSORPOS
                                  new-x y ,(if colon-flag '':PIXEL '':CHARACTER)))))))
             (T (funcall standard-output ':STRING-OUT "   "))))
    format-results))

(defprop [ format-ctl-start-case-macro eval-immediate)
(defun format-ctl-start-case-macro (args params &AUX (arg (car args)))
  (let ((inside-conditional T))
    (let ((clauses (format-parse-clauses '] T))
          (remaining-args 'NO-ARGS))
      (cond (colon-flag
              (cond (atsign-flag (format-error "~~:@[ is not a defined FORMAT command"))
                    (T (pop args))))
            (atsign-flag (*THROW 'IMPOSSIBLE 'IMPOSSIBLE))
            (T (pop args)))
      (push
        `(let ((arg
                 ,(COND (COLON-FLAG
                         (COND (ATSIGN-FLAG (FORMAT-ERROR
                                              "~~:@[ is not a defined FORMAT command"))
                               (T `(if ,ARG 1 0))))
                        (ATSIGN-FLAG
                         `(if ,ARG 0 -1))
                        ((CAR PARAMS) (CAR PARAMS))
                        (T arg))))
           ,(cons 'cond
                  (LOOP FOR clause ON (g-l-p clauses) BY #'CDDDR
                        FOR clause-number FROM 0
                        AS string = (first clause)
                        AS code = (let* ((final-format-results NIL)
                                         (arguments (format-ctl-string-macro args string)))
                                    (if (or (eq remaining-args 'NO-ARGS)
                                            (equal remaining-args arguments))
                                        (setq remaining-args arguments)
                                      (*Throw 'IMPOSSIBLE 'IMPOSSIBLE))
                                    (nreverse final-format-results))
                        COLLECT `((= ,clause-number arg)
                                  . ,code))))
       format-results)
      remaining-args)))

(defprop ] format-ctl-end-case-macro eval-immediate)
(defun format-ctl-end-case-macro (ignore)
  (format-error "Stray ~~] in FORMAT control string"))

(defun elim-lets (tree)
  (cond ((null tree) NIL)
        ((atom tree) tree)
        ((listp tree)
         (setq tree (eliminate-lets tree))
         (elim-lets (first tree))
         (elim-lets (cdr tree))
         tree)))

(defun eliminate-lets (tree)
  (if (and (listp tree)
           (listp (first tree))
           (listp (second tree)))
      (if (and (eq 'LET (first (first tree)))
               (eq 'LET (first (second tree))))
          ;; then maybe we can eliminate something
          (if (equal (second (first tree))(second (second tree)))
              ;; then we can eliminate the lets probably.
              (progn
                (setf (second tree)
                      `(let
                         ,(second (first tree))
                         ,(third (first tree))
                         ,(third (second tree))))
                (setf (first tree) '(progn)))
            tree)
        tree)
    tree))

(defprop /| format-ctl-forms-macro eval-immediate)
(defun format-ctl-forms-macro (params)
  (if colon-flag
      (push
        `(if (memq ':CLEAR-SCREEN (funcall standard-output ':WHICH-OPERATIONS))
             (funcall standard-output ':CLEAR-SCREEN)
           (format-ctl-repeat-char ,(or (first params) 1) #\FORM))
        format-results)
    (push `(format-ctl-repeat-char ,(or (first params) 1) #\FORM)
          format-results)))




(defprop { format-iterate-over-list-maco eval-immediate)
(defun format-iterate-over-list-maco (&REST ignore)
  (*Throw 'IMPOSSIBLE 'IMPOSSIBLE))

(defprop ^ format-ctl-terminate-macro eval-immediate)
(defun format-ctl-terminate-macro (&REST ignore)
  (*Throw 'IMPOSSIBLE 'IMPOSSIBLE))

;This is not so hairy as to work with ~T, tabs, crs.  I really don't see how to do that.
;It makes a list of strings, then decides how much spacing to put in,
;then goes back and outputs.
(defprop < format-hairy-justification-macro eval-immediate)
(defun format-hairy-justification-macro (&REST ignore)
  (*Throw 'IMPOSSIBLE 'IMPOSSIBLE))

(comment
(defun format-hairy-justification-macro (args params)
  (let ((mincol (or (first params) 0))
        (colinc (or (second params) 1))
        (minpad (or (third params) 0))
        (padchar (or (fourth params) #\SP))(temp-results NIL))
    `(let ((newline NIL)
           (extra 0)
           (linewidth NIL)
           (strings NIL)
           (string-ncol 0)
           (clauses)
           (n-padding-points -1)
           (total-padding)
           (n-pads)
           (n-extra-pads))
    (push '((W-O (FUNCALL STANDARD-OUTPUT ':WHICH-OPERATIONS))) temp-results)
    (and colon-flag (setq n-padding-points (1+ n-padding-points)))
    (and atsign-flag (setq n-padding-points (1+ n-padding-points)))
    (*catch 'FORMAT-^-POINT
        (progn (setq clauses (format-parse-clauses '> T))
               (do ((specs (g-l-p clauses) (cdddr specs)) (str))
                   ((null specs))
                 (multiple-value (args str-code)
                   (format-ctl-string-to-string args (car specs)))
                 (push `(setq str ,str-code) temp-results)
                 (push
                   `(progn
                      (setq string-ncol (+ (string-length str) string-ncol))
                      (setq n-padding-points (1+ n-padding-points))
                      (setq strings (cons-in-area str strings format-temporary-area)))
                   temp-results))))
    (push `(setq strings (nreverse strings)) temp-results)
    (cond ((and (g-l-p clauses) (oddp (cadr (g-l-p clauses))))
           (push `(progn
                    (setq newline (pop strings))
                    (and ,(caddr (g-l-p clauses))
                         (setq extra ,(or (car (g-l-p (caddr (g-l-p clauses)))) 0)
                               linewidth ,(cadr (g-l-p (caddr (g-l-p clauses))))))
                    (setq string-ncol (- string-ncol (string-length newline)))
                    (setq n-padding-points (1- n-padding-points)))
                 temp-results)))
    (push
      `(progn
         (and (zerop n-padding-points)          ;With no options and no ~; right-justify
              (setq colon-flag T n-padding-points 1))
         ;; Get the amount of space needed to print the strings and MINPAD padding
         (setq total-padding (+ (* n-padding-points minpad) string-ncol))
         ;; Now bring in the MINCOL and COLINC constraint, i.e. the total width is
         ;; at least MINCOL and exceeds MINCOL by a multiple of COLINC, and
         ;; get the total amount of padding to be divided among the padding points
         (setq total-padding (- (+ mincol (* colinc (// (+ (max (- total-padding mincol) 0)
                                                           (1- colinc))
                                                        colinc)))
                                string-ncol))
         ;; Figure out whether a newline is called for or not.
         (cond ((and newline
                     (memq ':READ-CURSORPOS w-o)
                     (> (+ (funcall standard-output ':READ-CURSORPOS ':CHARACTER)
                           string-ncol total-padding extra)
                        (or linewidth
                            (and (memq ':SIZE-IN-CHARACTERS w-o)
                                 (funcall standard-output ':SIZE-IN-CHARACTERS))
                            95.)))
                (funcall standard-output ':STRING-OUT newline)))
         ;; Decide how many pads at each padding point + how many of the leftmost
         ;; padding points need one extra pad.
         (setq n-pads (// total-padding n-padding-points)
               n-extra-pads (\ total-padding n-padding-points))
         (or (zerop n-extra-pads) (setq n-pads (1+ n-pads)))
         ;; Output the stuff
         (do ((strings strings (cdr strings))
              (pad-before-p colon-flag t))
             ((null strings))
           (cond (pad-before-p
                  (format-ctl-repeat-char n-pads ,padchar)
                  (and (zerop (setq n-extra-pads (1- n-extra-pads))) (setq n-pads (1- n-pads)))))
           (funcall standard-output ':STRING-OUT (first strings)))
         ;; Finally spacing at the right
         ,@(and atsign-flag `((format-ctl-repeat-char n-pads ,padchar)))
         ;; Reclamation
         (dolist (str (nreverse strings))
           (return-array str))
         (and newline (return-array newline))
         (format-reclaim-clauses clauses)) temp-results)
    (push
      (cons 'LET
            (nreverse temp-results)) format-results)
    args))))

(defprop > format-ctl-end-hairy-justification-macro eval-immediate)
(defun format-ctl-end-hairy-justification-macro (ignore)
  (format-error "Stray ~~> in FORMAT control string"))


;;; This function is like FORMAT-CTL-STRING except that instead of sending to
;;; STANDARD-OUTPUT it sends to a string and returns that as its second value.
;;; The returned string is in the temporary area.
(defun format-ctl-string-to-string-macro (args str)
  (let* ((format-results)
         (args-result (format-ctl-string args str)))
    (values args-result
            `(let ((format-string (make-array 200 ':AREA format-temporary-area
                                              ':TYPE 'ART-STRING
                                              ':LEADER-LIST '(0)))
                   (standard-output 'FORMAT-STRING-STREAM))
               ,@(nreverse format-results)
               (adjust-array-size format-string (array-active-length format-string))))))
